home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
ada
/
gwuada_9.zip
/
8.C
< prev
next >
Wrap
C/C++ Source or Header
|
1993-07-27
|
63KB
|
2,172 lines
/*
* Copyright (C) 1985-1992 New York University
*
* This file is part of the Ada/Ed-C system. See the Ada/Ed README file for
* warranty (none) and distribution info and also the GNU General Public
* License for more details.
*/
#ifndef SEM
#define SEM 1
#endif
#include "hdr.h"
#include "vars.h"
#include "attr.h"
#include "dclmapp.h"
#include "errmsgp.h"
#include "sspansp.h"
#include "nodesp.h"
#include "setp.h"
#include "miscp.h"
#include "smiscp.h"
#include "chapp.h"
/*
CHECK HANDLING OF NEW_NAME in newmod ds 30 jul
Sort out is_identifier usage ds 26 nov 84
Bring C version of find_simple_name in closer correspondence to SETL
version. ds 7 aug 84
Note that set imported in collect_imported names is built on every call.
It is probably dead on return, but I am not copying it when I put in
in all_imported_names. May be able to do set_free(imported) before
return from collect_imported_names - look into this later. ds 2 aug
*/
/*
* The following global variable is used for error reporting when
* several instances of an identifier end up hiding each other and
* the identifier is seen as undeclared or ambiguous.
*/
static Set all_imported_names; /*TBSL: initialize to (Set)0 */
static Set collect_imported_names(char *);
static void name_error(Node);
static void find_simple_name(Node);
static void array_or_call(Node);
static int parameterless_callable(Symbol);
static void index_or_slice(Node);
static void find_selected_comp(Node);
static void find_exp_name(Node, Symbol, char *);
static void all_declarations(Node, Symbol, char *, Symbol);
static int has_implicit_operator(Node, Symbol, char *);
static void make_any_id_node(Node);
static int is_appropriate_for_record(Symbol);
static int is_appropriate_for_task(Symbol);
static Symbol renamed(Node, Tuple, Symbol);
static Symbol op_matches_spec(Symbol, Tuple, Symbol);
static void check_modes(Tuple, Symbol);
static void renamed_entry(Node, Tuple);
void find_old(Node id_node) /*;find_old*/
{
/*
* Establish unique name of identifier, or of syntactic category name.
* Yield error in the case of undefined identifier.
* In the case of long and short integers, indicate that they are
* unimplemented rather than 'undefined'.
*/
Symbol u_name;
char *id;
char *newn;
int unsupported;
if (cdebug2 > 3)
TO_ERRFILE("AT PROC : find_old");
check_old(id_node);
if (N_KIND(id_node) != as_simple_name) return; /* added 7 jul */
u_name = N_OVERLOADED(id_node) ? (Symbol) 0 : N_UNQ(id_node);
id = N_VAL(id_node);
if (u_name == symbol_undef) {
if (streq(id, "LONG_INTEGER") || streq(id, "SHORT_INTEGER")) {
unsupported = TRUE;
u_name = symbol_integer; /* new type to use */
}
else if (streq(id, "SHORT_FLOAT") || streq(id, "LONG_FLOAT")) {
unsupported = TRUE;
u_name = symbol_float; /* new type to use */
}
else {
unsupported = FALSE;
}
if (!unsupported) {
/* The identifier is undefined, or not visible. This is an error.*/
name_error(id_node);
}
else {
/* The identifier names unsupported type. This is error, so
* issue error message and then change type to avoid further
* spurious error messages
*/
errmsg_str("% is not supported in current implementation",
id, "none", id_node);
N_UNQ(id_node) = u_name;
return;
}
/* insert in current scope, and give it default type.*/
if (dcl_get(DECLARED(scope_name), id) == (Symbol)0
&& set_size(all_imported_names) == 0) {
newn = id;
u_name = find_new(newn);
NATURE(u_name) = na_obj; /* Could be more precise.*/
N_UNQ(id_node) = u_name;
}
TYPE_OF(u_name) = symbol_any;
ALIAS(u_name) = symbol_any;
}
}
Symbol find_type(Node node) /*;find_type*/
{
Symbol type_mark;
/* Resolve a name that must yield a type mark.*/
find_old(node);
type_mark = N_UNQ(node);
if (N_OVERLOADED(node) || type_mark == (Symbol)0
|| !is_type(type_mark) && TYPE_OF(type_mark) != symbol_any) {
errmsg("Invalid type mark ", "none", node);
N_UNQ(node) = type_mark = symbol_any;
}
return type_mark;
}
static void name_error(Node id_node) /*;name_error*/
{
char *id;
char *names;
if (cdebug2 > 3)
TO_ERRFILE("AT PROC : name_error");
/*
* Name was not found in environment. This may be because it is undeclared,
* or because several imported instances of the name hide each other.
* The marker '?' is also returned when a type name is mentioned in
* the middle of its own elaboration.
*/
id = N_VAL(id_node);
if (set_size(all_imported_names) == 0) {
if (dcl_get(DECLARED(scope_name), id) == (Symbol)0) {
errmsg_str("identifier undeclared or not visible %", id, "3.1", id_node);
}
else {
errmsg_str("Invalid reference to %", id , "3.3", id_node);
}
}
else {
#ifdef TBSL
names = +/[ original_name(scope_of(x)) + '.' + original_name(x)
+ ' ': x in all_imported_names ];
#endif
names = build_full_names(all_imported_names);
errmsg_str("Ambiguous identifier. Could be one of: %",
names, "8.3, 8.4", id_node);
}
}
void check_old(Node n_node) /*;check_old*/
{
Node node, attr, arg1, expn;
int nk;
if (cdebug2 > 3) {
TO_ERRFILE("AT PROC : check_old");
printf(" kind %s\n", kind_str(N_KIND(n_node))); /*DEBUG*/
}
/*
* This procedure performs name resolution for several syntactic
* instances of names. These include identifiers, selected components,
* array indexing and slicing, function calls and attribute expressions.
* If -name- is an identifier and is undeclared, this proc yields
* the special marker '?' which is used by error routines.
* If -name- is overloaded, the procedure returns the set of overloaded
* names which correspond to -name-. This set is constructed by
* scanning first the open scopes, and then examining visible packages.
* To facilitate the collection of overloaded names, the procedure
* chain_overload, which is called when a procedure specification, or
* and enumeration type are processed, collects successive overloads of the
* same id together, using the -overloads- field of the symbol table.
*/
switch (nk = N_KIND(n_node)) {
case as_simple_name:
case as_character_literal:
case as_package_stub:
case as_task_stub:
find_simple_name(n_node);
break;
case as_call_unresolved:
array_or_call(n_node);
break;
case as_selector:
find_selected_comp(n_node);
break;
case as_string:
N_KIND(n_node) = as_simple_name; /* Treat as simple*/
find_simple_name(n_node); /* name.*/
break;
case as_name:
case as_range_expression:
node = N_AST1(n_node);
find_old(node);
copy_attributes(node, n_node);
break;
case as_attribute:
attr = N_AST1(n_node);
arg1 = N_AST2(n_node);
find_old(arg1);
break;
case as_all:
expn = N_AST1(n_node);
find_old(expn);
break;
}
}
static void find_simple_name(Node n_node) /*;find_simple_name*/
{
char *id;
Symbol sc;
int sc_num;
Symbol u_name, o, n, u_n;
Symbol found, foreign;
Set names, names_add, found_set;
Set imported;
int i, exists, found_is_set;
Forset fs1, fs2;
Symbol sym;
id = N_VAL(n_node);
if (cdebug2 > 0) {
TO_ERRFILE(" looking for id. " );
printf(" kind %s %s\n", kind_str(N_KIND(n_node)), id); /*DEBUG*/
}
exists = FALSE;
for (sc_num = 1; sc_num <= tup_size(open_scopes); sc_num++) {
sc = (Symbol)open_scopes[sc_num];
u_name = dcl_get(DECLARED(sc), id);
if (u_name != (Symbol)0) {
exists = TRUE;
break;
}
}
if (exists) {
if (!can_overload(u_name)) {
found_is_set = FALSE;
found = u_name;
TO_XREF(u_name);
}
else {
names = set_copy(OVERLOADS(u_name));
/* Scan open scopes for further overloadings.*/
for (i = sc_num+1; i <= tup_size(open_scopes); i++) {
u_n = dcl_get(DECLARED(((Symbol)open_scopes[i])), id);
if (u_n == (Symbol)0) continue;
else if (!can_overload(u_n)) {
found_is_set = TRUE;
found_set = names;
}
else {
names_add = set_new(0);
FORSET(o=(Symbol), OVERLOADS(u_n), fs1);
exists = FALSE;
FORSET(n=(Symbol), names, fs2);
if (same_type(TYPE_OF(n), TYPE_OF(o)) &&
same_signature(n, o)) {
exists = TRUE;
break;
}